/[gcl]/gcl/cmpnew/gcl_cmpenv.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmpenv.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:33 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:01 2003 UTC
# Line 0  Line 1 
1    ;;; CMPENV  Environments of the Compiler.
2    ;;;
3    ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
4    
5    ;; This file is part of GNU Common Lisp, herein referred to as GCL
6    ;;
7    ;; GCL is free software; you can redistribute it and/or modify it under
8    ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
9    ;; the Free Software Foundation; either version 2, or (at your option)
10    ;; any later version.
11    ;;
12    ;; GCL is distributed in the hope that it will be useful, but WITHOUT
13    ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14    ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public
15    ;; License for more details.
16    ;;
17    ;; You should have received a copy of the GNU Library General Public License
18    ;; along with GCL; see the file COPYING.  If not, write to the Free Software
19    ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
20    
21    
22    (in-package 'compiler)
23    
24    (defvar *safe-compile* nil)
25    (defvar *compiler-check-args* nil)
26    (defvar *compiler-push-events* nil)
27    (defvar *speed* 3)
28    (defvar *space* 0)
29    
30    ;;; Only these flags are set by the user.
31    ;;; If *safe-compile* is ON, some kind of run-time checks are not
32    ;;; included in the compiled code.  The default value is OFF.
33    
34    
35    
36    (defun init-env ()
37      (setq *next-cvar* 0)
38      (setq *next-cmacro* 0)
39      (setq *next-vv* -1)
40      (setq *next-cfun* 0)
41      (setq *last-label* 0)
42      (setq *objects* nil)
43      (setq *constants* nil)
44      (setq *local-funs* nil)
45      (setq *global-funs* nil)
46      (setq *global-entries* nil)
47      (setq *undefined-vars* nil)
48      (setq *reservations* nil)
49      (setq *closures* nil)
50      (setq *top-level-forms* nil)
51      (setq *non-package-operation* nil)
52      (setq *function-declarations* nil)
53      (setq *inline-functions* nil)
54      (setq *inline-blocks* 0)
55      (setq *notinline* nil)
56      )
57    
58    (defvar *next-cvar* 0)
59    (defvar *next-cmacro* 0)
60    (defvar *next-vv* -1)
61    (defvar *next-cfun* 0)
62    
63    ;;; *next-cvar* holds the last cvar number used.
64    ;;; *next-cmacro* holds the last cmacro number used.
65    ;;; *next-vv* holds the last VV index used.
66    ;;; *next-cfun* holds the last cfun used.
67    
68    (defmacro next-cfun () '(incf *next-cfun*))
69    
70    (defun add-symbol (symbol)
71      (let ((x (assoc symbol *objects*)))
72           (cond (x (cadr x))
73                 (t (push-data-incf symbol)
74                    (push (list symbol *next-vv*) *objects*)
75                    *next-vv*))))
76    
77    ;; Write to a string with all the *print-.. levels bound appropriately.
78    (defun wt-to-string (x &aux
79                           (*compiler-output-data* (make-string-output-stream))
80                           *fasd-data*)
81      (wt-data1 x)
82      (get-output-stream-string *compiler-output-data*))
83    
84    (defun add-object (object &aux x)
85      ;;; Used only during Pass 1.
86      (cond ((si:contains-sharp-comma object)
87             ;;; SI:CONTAINS-SHARP-COMMA returns T iff OBJECT
88             ;;; contains a sharp comma OR a structure.
89             ;; there will be an eval and we want the eval to happen
90             (cond ((and
91                     (consp object)
92                     (eq (car object) 'si::|#,|)
93                     (not (si:contains-sharp-comma (cdr object))))
94                    (setq object (cdr object)))
95                   (t (setq object `(si::string-to-object
96                                     ,(wt-to-string object)))))
97             (push-data-incf nil)
98             (push (list *next-vv* object) *sharp-commas*)
99             *next-vv*)
100            ((setq x (assoc object *objects*))
101             (cadr x))
102            ((typep object 'compiled-function)
103             (push-data-incf nil)
104             (push (list *next-vv* `(function
105                                     ,(or (si::compiled-function-name
106                                           object)
107                                          (cmperr "Can't dump un named compiled funs")
108                                          )))
109                                     *sharp-commas*)
110             *next-vv*
111             )
112            (t
113               (push-data-incf object)
114               (push (list object *next-vv*) *objects*)
115               *next-vv*)))
116    
117    (defun add-constant (symbol &aux x)
118      ;;; Used only during Pass 1.
119      (cond ((setq x (assoc symbol *constants*))
120             (cadr x))
121            (t (push-data-incf nil)
122               (push (list *next-vv* symbol) *sharp-commas*)
123               (push (list symbol *next-vv*) *constants*)
124               *next-vv*)))
125    
126    (defmacro next-cvar () '(incf *next-cvar*))
127    (defmacro next-cmacro () '(incf *next-cmacro*))
128    
129    ;;; Tail recursion information.
130    (defvar *do-tail-recursion* t)
131    (defvar *tail-recursion-info* nil)
132    ;;; Tail recursion optimization never occurs if *do-tail-recursion* is NIL.
133    ;;; *tail-recursion-info* holds NIL, if tail recursion is impossible.
134    ;;; If possible, *tail-recursion-info* holds
135    ;;;     ( fname  required-arg .... required-arg ),
136    ;;; where each required-arg is a var-object.
137    
138    
139    (defvar *function-declarations* nil)
140    ;;; *function-declarations* holds :
141    ;;;     (... ( { function-name | fun-object } arg-types return-type ) ...)
142    ;;; Function declarations for global functions are ASSOCed by function names,
143    ;;; whereas those for local functions are ASSOCed by function objects.
144    ;;;
145    ;;; The valid argment type declaration is:
146    ;;;     ( {type}* [ &optional {type}* ] [ &rest type ] [ &key {type}* ] )
147    ;;; though &optional, &rest, and &key return types are simply ignored.
148    
149    (defun function-arg-types (arg-types &aux vararg (types nil) result)
150      (setq result
151            (do ((al arg-types (cdr al))
152                 (i 0 (the fixnum (+ 1 i))))
153                ((endp al)
154                 (reverse types))
155                (declare (fixnum i))
156                (cond ((or (member (car al) '(&optional &rest &key))
157                           (equal (car al) '* ))
158                       (setq vararg t)
159                       (return (reverse (cons '* types)))))
160                ;; only the first 9 args may have proclaimed type different from T
161                (push       (cond
162                                   ((< i 9)
163                                    (let ((tem
164                                           (type-filter (car al))))
165                                      (if (eq 'integer tem) t tem)))
166                                  (t (if (eq (car al) '*) '* t)))
167                            types)))
168      ;;only type t args for var arg so far.
169      (cond (vararg (do ((v result (cdr v)))
170                        ((null v))
171                        (setf (car v) (if (eq (car v) '*) '* t)))))
172                        
173      result)
174    
175    
176    ;;; The valid return type declaration is:
177    ;;;     (( VALUES {type}* )) or ( {type}* ).
178    
179    (defun function-return-type (return-types)
180      (and (eq (car return-types) 'values)
181           (setq return-types (cdr return-types)))
182      (cond ((endp return-types) nil)
183            ((and (consp (car return-types))
184                  (eq (caar return-types) 'values))
185             (function-return-type (cdr (car return-types))))
186            (t (do ((v return-types (cdr v))
187                    (result))
188                   ((endp v)(or (null v)
189                                (warn "The function return type ~s is illegal."
190                                      return-types))
191                    (nreverse result))
192                 (let ((tem  (if (eq (car v) '*) '* (type-filter (car v)))))
193                   (if (eq tem 'integer) (setq tem t))
194                   (push  tem result))))))
195                    
196    (defun add-function-proclamation (fname decl list &aux (procl t)
197                                            arg-types return-types)
198      (cond
199        ((and (symbolp fname)
200              (listp decl) (listp (cdr decl)))
201         (cond ((or (null decl)(eq (car decl) '*)) (setq arg-types '(*)))
202               (t (setq arg-types (function-arg-types (car decl)))
203    
204                  ))
205         (setq return-types (function-return-type (cdr decl)))
206         (cond ((and (consp return-types)  ; ie not nil
207                     (endp (cdr return-types))
208                     (not (eq (car return-types) '*)))
209                (setq return-types
210                      ;; varargs must return type t currently.
211                      (if (member '* (and (consp arg-types) arg-types)) t
212                          (car return-types))))
213               (t (setq procl nil)))
214         (cond ((and (listp arg-types)
215                     (< (length arg-types) call-arguments-limit)))
216               (t (setq procl nil)))
217         (do ((fname fname (car list)))
218             (())
219             (or (symbolp fname)
220                 (return (add-function-proclamation fname decl nil)))
221             (if (eq arg-types '*)
222                 (remprop fname  'proclaimed-arg-types)
223               (si:putprop fname  arg-types  'proclaimed-arg-types))
224             (si:putprop fname return-types  'proclaimed-return-type)
225        
226             ;;; A non-local function may have local entry only if it returns
227             ;;; a single value.
228    
229             (if procl  (si:putprop fname t 'proclaimed-function)
230               (remprop fname 'proclaimed-function))
231             (setq list (cdr list))
232             (or (consp list) (return 'done))
233             ))
234        (t (warn "The function procl ~s ~s is not valid." fname decl))))
235    
236    (defun add-function-declaration (fname arg-types return-types)
237      (cond ((symbolp fname)
238             (push (list (sch-local-fun fname)
239                         (function-arg-types arg-types)
240                         (function-return-type return-types))
241                   *function-declarations*))
242            (t (warn "The function name ~s is not a symbol." fname))))
243    
244    (defun get-arg-types (fname &aux x)
245      (if (setq x (assoc fname *function-declarations*))
246          (cadr x)
247          (get fname 'proclaimed-arg-types)))
248    
249    (defun get-return-type (fname)
250      (let* ((x (assoc fname *function-declarations*))
251             (type1 (if x (caddr x) (get fname 'proclaimed-return-type)))
252             (type (if (get fname 'predicate) 'boolean
253                     (get fname 'return-type))))
254            (cond (type1
255                   (cond (type
256                          (cond ((setq type (type-and type type1)) type)
257                                (t
258                                 (cmpwarn
259                                  "The return type of ~s was badly declared."
260                                  fname))))
261                         (t type1)))
262                  (t type))))
263    
264    (defun get-local-arg-types (fun &aux x)
265      (if (setq x (assoc fun *function-declarations*))
266          (cadr x)
267          nil))
268    
269    (defun get-local-return-type (fun &aux x)
270      (if (setq x (assoc fun *function-declarations*))
271          (caddr x)
272          nil))
273    
274    (defvar *sup-used* nil)
275    (defvar *base-used* nil)
276    
277    (defun reset-top ()
278           (wt "vs_top=sup;")
279           (setq *sup-used* t))
280    
281    (defmacro base-used () '(setq *base-used* t))
282    
283    ;;; Proclamation and declaration handling.
284    
285    (defvar *alien-declarations* nil)
286    (defvar *notinline* nil)
287    
288    (defun inline-possible (fname)
289           (not (or *compiler-push-events*
290                    (member fname *notinline*)
291                    (get fname 'cmp-notinline))))
292    
293    (defun proclaim (decl)
294      (case (car decl)
295        (special
296         (dolist** (var (cdr decl))
297           (if (symbolp var)
298               (si:*make-special var)
299               (warn "The variable name ~s is not a symbol." var))))
300        (optimize
301         (dolist (x (cdr decl))
302           (when (symbolp x) (setq x (list x 3)))
303           (if (or (not (consp x))
304                   (not (consp (cdr x)))
305                   (not (numberp (cadr x)))
306                   (not (<= 0 (cadr x) 3)))
307               (warn "The OPTIMIZE proclamation ~s is illegal." x)
308               (case (car x)
309                     (safety (setq *compiler-check-args* (>= (cadr x) 1))
310                             (setq *safe-compile* (>= (cadr x) 2))
311                             (setq *compiler-push-events* (>= (cadr x) 3)))
312                     (space (setq *space* (cadr x)))
313                     (speed (setq *speed* (cadr x)))
314                     (compilation-speed (setq *speed* (- 3 (cadr x))))
315                     (t (warn "The OPTIMIZE quality ~s is unknown." (car x)))))))
316        (type
317         (if (consp (cdr decl))
318             (proclaim-var (cadr decl) (cddr decl))
319             (warn "The type declaration ~s is illegal." decl)))
320        ((fixnum character short-float long-float)
321         (proclaim-var (car decl) (cdr decl)))
322        (ftype
323          (cond ((and (consp (cdr decl))
324                      (consp (cadr decl))
325                      (eq (caadr decl) 'function))
326                 (add-function-proclamation (caddr decl) (cdr (cadr decl))
327                                            (cddr decl)))
328              (t (cmpwarn "Bad function proclamation ~a" decl))))
329       (function
330        (cond ((and (consp (cdr decl)))
331                    (add-function-proclamation (cadr decl) (cddr decl) nil))
332              (t (cmpwarn "Bad function proclamation ~a" decl))))
333        (inline
334         (dolist** (fun (cdr decl))
335                   (if (symbolp fun)
336                       (remprop fun 'cmp-notinline)
337                       (warn "The function name ~s is not a symbol." fun))))
338        (notinline
339         (dolist** (fun (cdr decl))
340                   (if (symbolp fun)
341                       (si:putprop fun t 'cmp-notinline)
342                       (warn "The function name ~s is not a symbol." fun))))
343        ((object ignore)
344         (dolist** (var (cdr decl))
345           (unless (symbolp var)
346                   (warn "The variable name ~s is not a symbol." var))))
347        (declaration
348         (dolist** (x (cdr decl))
349           (if (symbolp x)
350               (unless (member x *alien-declarations*)
351                       (push x *alien-declarations*))
352               (warn "The declaration specifier ~s is not a symbol." x))))
353        ((array atom bignum bit bit-vector character common compiled-function
354          complex cons double-float fixnum float hash-table integer keyword list
355          long-float nil null number package pathname random-state ratio rational
356          readtable sequence short-float simple-array simple-bit-vector
357          simple-string simple-vector single-float standard-char stream string
358          string-char symbol t vector signed-byte unsigned-byte)
359         (proclaim-var (car decl) (cdr decl)))
360        (otherwise
361         (unless (member (car decl) *alien-declarations*)
362                 (warn "The declaration specifier ~s is unknown." (car decl)))
363       (and (functionp (get (car decl) :proclaim))
364            (dolist** (v (cdr decl))
365              (funcall (get (car decl) :proclaim) v)))
366    )
367        )
368      nil
369      )
370    
371    (defun proclaim-var (type vl)
372      (setq type (type-filter type))
373      (dolist** (var vl)
374        (cond ((symbolp var)
375               (let ((type1 (get var 'cmp-type))
376                     (v (sch-global var)))
377                    (setq type1 (if type1 (type-and type1 type) type))
378                    (when v (setq type1 (type-and type1 (var-type v))))
379                    (when (null type1) (warn
380          "Inconsistent type declaration was found for the variable ~s."
381                                        var))
382                    (si:putprop var type1 'cmp-type)
383                    (when v (setf (var-type v) type1))))
384              (t
385               (warn "The variable name ~s is not a symbol." var)))))
386    
387    (defun c1body (body doc-p &aux (ss nil) (is nil) (ts nil) (others nil)
388                        doc form)
389      (loop
390        (when (endp body) (return))
391        (setq form (cmp-macroexpand (car body)))
392        (cond
393         ((stringp form)
394          (when (or (null doc-p) (endp (cdr body)) doc) (return))
395          (setq doc form))
396         ((and (consp form) (eq (car form) 'declare))
397          (dolist** (decl (cdr form))
398            (cmpck (or (not (consp decl)) (not (symbolp (car decl))))
399                   "The declaration ~s is illegal." decl)
400            (case (car decl)
401              (special
402               (dolist** (var (cdr decl))
403                 (cmpck (not (symbolp var))
404                        "The special declaration ~s contains a non-symbol ~s."
405                        decl var)
406                 (push var ss)))
407              (ignore
408               (dolist** (var (cdr decl))
409                 (cmpck (not (symbolp var))
410                        "The ignore declaration ~s contains a non-symbol ~s."
411                        decl var)
412                 (push var is)))
413              (type
414               (cmpck (endp (cdr decl))
415                      "The type declaration ~s is illegal." decl)
416               (let ((type (type-filter (cadr decl))))
417                    (when type
418                          (dolist** (var (cddr decl))
419                            (cmpck (not (symbolp var))
420                              "The type declaration ~s contains a non-symbol ~s."
421                              decl var)
422                            (push (cons var type) ts)))))
423              (object
424               (dolist** (var (cdr decl))
425                 (cmpck (not (symbolp var))
426                        "The object declaration ~s contains a non-symbol ~s."
427                        decl var)
428                 (push (cons var 'object) ts)))
429              (:register
430               (dolist** (var (cdr decl))
431                 (cmpck (not (symbolp var))
432                        "The register declaration ~s contains a non-symbol ~s."
433                        decl var)
434                 (push (cons var  'register) ts)
435                 ))
436              ((fixnum character double-float short-float array atom bignum bit
437                bit-vector common compiled-function complex cons float hash-table
438                integer keyword list long-float nil null number package pathname
439                random-state ratio rational readtable sequence simple-array
440                simple-bit-vector simple-string simple-vector single-float
441                standard-char stream string string-char symbol t vector
442                signed-byte unsigned-byte :dynamic-extent)
443               (let ((type (if (eq (car decl) ':dynamic-extent) (car decl)
444                             (type-filter (car decl)))))
445                    (when type
446                          (dolist** (var (cdr decl))
447                            (cmpck (not (symbolp var))
448                              "The type declaration ~s contains a non-symbol ~s."
449                              decl var)
450                            (push (cons var type) ts)))))
451              (otherwise (push decl others))
452              )))
453         (t (return)))
454        (pop body)
455        )
456      (values body ss ts is others doc)
457      )
458    
459    (defun c1decl-body (decls body &aux (dl nil))
460      (if (null decls)
461          (c1progn body)
462          (let ((*function-declarations* *function-declarations*)
463                (*alien-declarations* *alien-declarations*)
464                (*notinline* *notinline*)
465                (*space* *space*)
466                (*safe-compile* *safe-compile*))
467               (dolist** (decl decls dl)
468                 (case (car decl)
469                  (optimize
470                   (dolist (x (cdr decl))
471                     (when (symbolp x) (setq x (list x 3)))
472                     (if (or (not (consp x))
473                             (not (consp (cdr x)))
474                             (not (numberp (cadr x)))
475                             (not (<= 0 (cadr x) 3)))
476                         (warn "The OPTIMIZE proclamation ~s is illegal." x)
477                         (case (car x)
478                               (safety
479                                 (setq *safe-compile*
480                                       (>= (the fixnum (cadr x)) 2))
481                                 (push (list 'safety (cadr x)) dl))
482                               (space (setq *space* (cadr x))
483                                      (push (list 'space (cadr x)) dl))
484                               ((speed compilation-speed))
485                               (t (warn "The OPTIMIZE quality ~s is unknown."
486                                        (car x)))))))
487                  (ftype
488                   (if (or (endp (cdr decl))
489                           (not (consp (cadr decl)))
490                           (not (eq (caadr decl) 'function))
491                           (endp (cdadr decl)))
492                       (warn "The function declaration ~s is illegal." decl)
493                       (dolist** (fname (cddr decl))
494                         (add-function-declaration
495                          fname (cadadr decl) (cddadr decl)))))
496                  (function
497                   (if (or (endp (cdr decl))
498                           (endp (cddr decl))
499                           (not (symbolp (cadr decl))))
500                       (warn "The function declaration ~s is illegal." decl)
501                       (add-function-declaration
502                        (cadr decl) (caddr decl) (cdddr decl))))
503                  (inline
504                   (dolist** (fun (cdr decl))
505                     (if (symbolp fun)
506                         (progn (push (list 'inline fun) dl)
507                                (setq *notinline* (remove fun *notinline*)))
508                         (warn "The function name ~s is not a symbol." fun))))
509                  (notinline
510                   (dolist** (fun (cdr decl))
511                     (if (symbolp fun)
512                         (progn (push (list 'notinline fun) dl)
513                                (push fun *notinline*))
514                         (warn "The function name ~s is not a symbol." fun))))
515                  (declaration
516                   (dolist** (x (cdr decl))
517                     (if (symbolp x)
518                         (unless (member x *alien-declarations*)
519                                 (push x *alien-declarations*))
520                         (warn "The declaration specifier ~s is not a symbol."
521                               x))))
522                  (otherwise
523                   (unless (member (car decl) *alien-declarations*)
524                     (warn "The declaration specifier ~s is unknown."
525                           (car decl))))
526                  ))
527               (setq body (c1progn body))
528               (list 'decl-body (cadr body) dl body)
529               )
530          )
531      )
532    
533    (si:putprop 'decl-body 'c2decl-body 'c2)
534    
535    (defun c2decl-body (decls body)
536      (let ((*compiler-check-args* *compiler-check-args*)
537            (*safe-compile* *safe-compile*)
538            (*compiler-push-events* *compiler-push-events*)
539            (*notinline* *notinline*)
540            (*space* *space*)
541            )
542           (dolist** (decl decls)
543             (case (car decl)
544                   (safety
545                    (let ((level (cadr decl)))
546                         (declare (fixnum level))
547                         (setq *compiler-check-args* (>= level 1)
548                               *safe-compile* (>= level 2)
549                               *compiler-push-events* (>= level 3))))
550                   (space (setq *space* (cadr decl)))
551                   (notinline (push (cadr decl) *notinline*))
552                   (inline
553                    (setq *notinline* (remove (cadr decl) *notinline*)))
554                   (otherwise (baboon))))
555           (c2expr body))
556      )
557    
558    (defun check-vdecl (vnames ts is)
559      (dolist** (x ts)
560        (unless (member (car x) vnames)
561          (cmpwarn "Type declaration was found for not bound variable ~s."
562                   (car x))))
563      (dolist** (x is)
564        (unless (member x vnames)
565          (cmpwarn "Ignore declaration was found for not bound variable ~s." x)))
566      )
567    
568    (defun proclamation (decl)
569      (case (car decl)
570        (special
571         (dolist** (var (cdr decl) t)
572           (if (symbolp var)
573               (unless (si:specialp var) (return nil))
574               (warn "The variable name ~s is not a symbol." var))))
575        (optimize
576         (dolist (x (cdr decl) t)
577           (when (symbolp x) (setq x (list x 3)))
578           (if (or (not (consp x))
579                   (not (consp (cdr x)))
580                   (not (numberp (cadr x)))
581                   (not (<= 0 (cadr x) 3)))
582               (warn "The OPTIMIZE proclamation ~s is illegal." x)
583               (case (car x)
584                     (safety
585                      (unless (= (cadr x)
586                                 (cond ((null *compiler-check-args*) 0)
587                                       ((null *safe-compile*) 1)
588                                       ((null *compiler-push-events*) 2)
589                                       (t 3)))
590                              (return nil)))
591                     (space (unless (= (cadr x) *space*) (return nil)))
592                     (speed (unless (= (cadr x) *speed*) (return nil)))
593                     (compilation-speed
594                      (unless (= (- 3 (cadr x)) *speed*) (return nil)))
595                     (t (warn "The OPTIMIZE quality ~s is unknown."
596                              (car x)))))))
597        (type
598         (if (consp (cdr decl))
599             (let ((type (type-filter (cadr decl)))
600                   x)
601                  (dolist** (var (cddr decl) t)
602                    (if (symbolp var)
603                        (unless (and (setq x (get var 'cmp-type))
604                                     (equal x type))
605                                (return nil))
606                        (warn "The variable name ~s is not a symbol." var))))
607             (warn "The type declaration ~s is illegal." decl)))
608        ((fixnum character short-float long-float)
609         (let ((type (type-filter (car decl)))
610               x)
611              (dolist** (var (cdr decl) t)
612                (if (symbolp var)
613                    (unless (and (setq x (get var 'cmp-type)) (equal x type))
614                            (return nil))
615                    (warn "The variable name ~s is not a symbol." var)))))
616        (ftype
617         (if (or (endp (cdr decl))
618                 (not (consp (cadr decl)))
619                 (not (eq (caadr decl) 'function))
620                 (endp (cdadr decl)))
621             (warn "The function declaration ~s is illegal." decl)
622             (dolist** (fname (cddr decl) t)
623               (unless (and (get fname 'proclaimed-function)
624                            (equal (function-arg-types (cadadr decl))
625                                   (get fname 'proclaimed-arg-types))
626                            (equal (function-return-type (cddadr decl))
627                                   (get fname 'proclaimed-return-type)))
628                       (return nil)))))
629        (function
630         (if (or (endp (cdr decl)) (endp (cddr decl)))
631             (warn "The function declaration ~s is illegal." decl)
632             (and (get (cadr decl) 'proclaimed-function)
633                  (equal (function-arg-types (caddr decl))
634                         (get (cadr decl) 'proclaimed-arg-types))
635                  (equal (function-return-type (cdddr decl))
636                         (get (cadr decl) 'proclaimed-return-type)))))
637        (inline (dolist** (fun (cdr decl) t)
638                  (if (symbolp fun)
639                      (when (get fun 'cmp-notinline) (return nil))
640                      (warn "The function name ~s is not a symbol." fun))))
641        (notinline (dolist** (fun (cdr decl) t)
642                     (if (symbolp fun)
643                         (unless (get fun 'cmp-notinline) (return nil))
644                         (warn "The function name ~s is not a symbol." fun))))
645        ((object ignore)
646         (dolist** (var (cdr decl) t)
647                   (unless (symbolp var)
648                           (warn "The variable name ~s is not a symbol." var))))
649        (declaration (dolist** (x (cdr decl) t)
650                       (if (symbolp x)
651                           (unless (member x *alien-declarations*) (return nil))
652                           (warn "The declaration specifier ~s is not a symbol."
653                                 x))))
654        ((array atom bignum bit bit-vector character common compiled-function
655          complex cons double-float fixnum float hash-table integer keyword list
656          long-float nil null number package pathname random-state ratio rational
657          readtable sequence short-float simple-array simple-bit-vector
658          simple-string simple-vector single-float standard-char stream string
659          string-char symbol t vector signed-byte unsigned-byte)
660         (let ((type (type-filter (car decl))))
661              (dolist** (var (cdr decl) t)
662                (if (symbolp var)
663                    (unless (equal (get var 'cmp-type) type) (return nil))
664                    (warn "The variable name ~s is not a symbol." var)))))
665        (otherwise
666         (unless (member (car decl) *alien-declarations*)
667                 (warn "The declaration specifier ~s is unknown." (car decl))))
668        )
669      )
670    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26