← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to lsp/gcl_make-declare.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
lsp/gcl_make-declare.lsp
 
1
;; By W. Schelter
 
2
;; Usage: (si::proclaim-file "foo.lsp") (compile-file "foo.lsp")
 
3
 
 
4
(in-package 'si)
 
5
 
 
6
;; You may wish to adjust the following to output the proclamations
 
7
;; for inclusion in a file.  All fixed arg functions should be proclaimed
 
8
;; before their references for maximum efficiency.
 
9
 
 
10
;; CAVEAT: The following code only checks for fixed args, it does
 
11
;; not check for single valuedness BUT does make a proclamation
 
12
;; to that effect.  Unfortunately it is impossible to tell about
 
13
;; multiple values without doing a full compiler type pass over 
 
14
;; all files in the relevant system.   However the GCL compiler should
 
15
;; warn if you inadvertantly proclaim foo to be single valued and then try
 
16
;; to use more than one value.  
 
17
 
 
18
(DEFVAR *DECLARE-T-ONLY* NIL)
 
19
(DEFUN PROCLAIM-FILE (NAME &OPTIONAL *DECLARE-T-ONLY*)
 
20
  (WITH-OPEN-FILE 
 
21
      (FILE NAME
 
22
            :DIRECTION :INPUT)
 
23
    (LET ((EOF (CONS NIL NIL)))
 
24
      (LOOP
 
25
       (LET ((FORM (READ FILE NIL EOF)))
 
26
         (COND ((EQ EOF FORM) (RETURN NIL))
 
27
               ((MAKE-DECLARE-FORM FORM ))))))))
 
28
 
 
29
(DEFVAR *DEFUNS* '(DEFUN))
 
30
 
 
31
(DEFUN MAKE-DECLARE-FORM (FORM)
 
32
; !!!
 
33
  (WHEN
 
34
        (LISTP FORM)
 
35
   (COND ((MEMBER (CAR FORM) '(EVAL-WHEN ))
 
36
          (DOLIST (V (CDDR FORM)) (MAKE-DECLARE-FORM V)))
 
37
         ((MEMBER (CAR FORM) '(PROGN ))
 
38
          (DOLIST (V (CDR FORM)) (MAKE-DECLARE-FORM V)))
 
39
         ((MEMBER (CAR FORM) '(IN-PACKAGE DEFCONSTANT))
 
40
          (EVAL FORM))
 
41
         ((MEMBER (CAR FORM) *DEFUNS*)
 
42
          (COND
 
43
           ((AND
 
44
             (CONSP (CADDR FORM))
 
45
             (NOT (MEMBER '&REST (CADDR FORM)))
 
46
             (NOT (MEMBER '&BODY (CADDR FORM)))
 
47
             (NOT (MEMBER '&KEY (CADDR FORM)))
 
48
             (NOT (MEMBER '&OPTIONAL (CADDR FORM))))
 
49
             ;;could print  declarations here.
 
50
            ;(print (list (cadr form)(ARG-DECLARES (THIRD FORM)(cdddr FORM))))
 
51
            (FUNCALL 'PROCLAIM
 
52
                     (LIST  'FUNCTION
 
53
                            (CADR FORM)
 
54
                            (ARG-DECLARES (THIRD FORM) (cdddr FORM))
 
55
                            T))))))))
 
56
 
 
57
(DEFUN ARG-DECLARES (ARGS DECLS &AUX ANS)
 
58
  (COND ((STRINGP (CAR DECLS)) (SETQ DECLS (CADR DECLS)))
 
59
        (T (SETQ DECLS (CAR DECLS))))
 
60
  (COND ((AND (not *declare-t-only*)
 
61
               (CONSP DECLS) (EQ (CAR DECLS ) 'DECLARE))
 
62
         (DO ((V ARGS (CDR V)))
 
63
             ((OR (EQ (CAR V) '&AUX)
 
64
                  (NULL V))
 
65
              (NREVERSE ANS))
 
66
             (PUSH (DECL-TYPE (CAR V) DECLS) ANS)))
 
67
        (T (MAKE-LIST (- (LENGTH args)
 
68
                         (LENGTH (MEMBER '&AUX args)))
 
69
                      :INITIAL-ELEMENT T))))
 
70
 
 
71
(DEFUN DECL-TYPE (V DECLS)
 
72
  (DOLIST (D (CDR DECLS))
 
73
          (CASE (CAR D)
 
74
                (TYPE (IF (MEMBER V (CDDR D))
 
75
                        (RETURN-FROM DECL-TYPE (SECOND D))))
 
76
                ((FIXNUM CHARACTER FLOAT LONG-FLOAT SHORT-FLOAT )
 
77
                 (IF (MEMBER V (CDR D)) (RETURN-FROM DECL-TYPE (CAR D))))))
 
78
  T)
 
79
                            
 
80
              
 
 
b'\\ No newline at end of file'