Skip to content
Newer
Older
100644 157 lines (132 sloc) 4.72 KB
90d2d18 @feeley Added check for consistency of lib/gambit#.scm .
authored
1 ;;;============================================================================
2
3 ;;; File: "check-consistency.scm", Time-stamp: <2008-11-26 20:24:28 feeley>
4
5 ;;; Copyright (c) 2008 by Marc Feeley, All Rights Reserved.
6
7 ;;;============================================================================
8
9 ;; Check that the lib/gambit#.scm file is consistent with the
10 ;; compiler's public procedures and special forms.
11
12 (define (main)
13
14 (define pretend-defined-by-gambit '(
15 define-syntax
16 let-syntax
17 letrec-syntax
18 syntax-rules
19 six.!
20 six.break
21 six.case
22 six.clause
23 six.continue
24 six.goto
25 six.label
26 six.return
27 six.switch
28 six.x:-y
29 default-random-source
30 ))
31
32 (define (keep keep? lst)
33 (cond ((null? lst) '())
34 ((keep? (car lst)) (cons (car lst) (keep keep? (cdr lst))))
35 (else (keep keep? (cdr lst)))))
36
37 (define (sort-list lst <?)
38
39 (define (mergesort lst)
40
41 (define (merge lst1 lst2)
42 (cond ((null? lst1) lst2)
43 ((null? lst2) lst1)
44 (else
45 (let ((e1 (car lst1)) (e2 (car lst2)))
46 (if (<? e1 e2)
47 (cons e1 (merge (cdr lst1) lst2))
48 (cons e2 (merge lst1 (cdr lst2))))))))
49
50 (define (split lst)
51 (if (or (null? lst) (null? (cdr lst)))
52 lst
53 (cons (car lst) (split (cddr lst)))))
54
55 (if (or (null? lst) (null? (cdr lst)))
56 lst
57 (let* ((lst1 (mergesort (split lst)))
58 (lst2 (mergesort (split (cdr lst)))))
59 (merge lst1 lst2))))
60
61 (mergesort lst))
62
63 (define (symbol-table->list st)
64 (apply append
65 (map (lambda (s)
66 (let loop ((s s) (lst '()))
67 (if (symbol? s)
68 (loop (##vector-ref s 2) (cons s lst))
69 (reverse lst))))
70 (vector->list st))))
71
72 (define (public-procedure? s)
73 (if (let ((str (symbol->string s)))
74 (or (memv #\# (string->list str))
75 #;
76 (and (>= (string-length str) 2)
77 (equal? (substring str 0 2) "##"))
78 (and (>= (string-length str) 1)
79 (equal? (substring str 0 1) " "))))
80
81 #f
82 (let ((val (##global-var-ref (##make-global-var s))))
83 (procedure? val))))
84
85 (define (extract-macros cte)
86 (cond ((##cte-top? cte)
87 '())
88 ((##cte-macro? cte)
89 (cons (##cte-macro-name cte)
90 (extract-macros (##cte-parent-cte cte))))
91 (else
92 (extract-macros (##cte-parent-cte cte)))))
93
94 (define (read-namespace-names filename)
95 (let ((ns (assq '##namespace (with-input-from-file filename read-all))))
96 (if ns
97 (cdr (cadr ns))
98 '())))
99
100 (define (gambit-macros)
101 (extract-macros (##cte-top-cte ##interaction-cte)))
102
103 (define (sort-symbols lst)
104 (sort-list
105 lst
106 (lambda (x y) (string<? (symbol->string x) (symbol->string y)))))
107
108 (let* ((public-procedures
109 (keep public-procedure?
110 (symbol-table->list (##symbol-table))))
111 (public-macros
112 (gambit-macros))
113 (sorted-public-names
114 (sort-symbols
115 (append public-macros
116 public-procedures
117 pretend-defined-by-gambit)))
118 (r4rs-public-names
119 (read-namespace-names "../lib/r4rs#.scm"))
120 (r5rs-public-names
121 (append
122 r4rs-public-names
123 (read-namespace-names "../lib/r5rs#.scm")))
124 (gambit-public-names
125 (append
126 r5rs-public-names
127 (read-namespace-names "../lib/gambit#.scm")))
128 (missing-from-gambit-public-names
129 (keep (lambda (name)
130 (not (memq name gambit-public-names)))
131 sorted-public-names))
132 (extras-in-gambit-public-names
133 (keep (lambda (name)
134 (not (memq name sorted-public-names)))
135 gambit-public-names)))
136
137 (if (or (not (null? extras-in-gambit-public-names))
138 (not (null? missing-from-gambit-public-names)))
139 (begin
140 (display "************ file lib/gambit#.scm needs to be edited ************\n")
141 (newline)
142 (if (not (null? extras-in-gambit-public-names))
143 (begin
144 (display "==== these names should be REMOVED ====\n")
145 (for-each pp extras-in-gambit-public-names)
146 (newline)))
147 (if (not (null? missing-from-gambit-public-names))
148 (begin
149 (display "==== these names should be ADDED ====\n")
150 (for-each pp missing-from-gambit-public-names)))
151 (exit 1))
152 (exit))))
153
154 (main)
155
156 ;;;============================================================================
Something went wrong with that request. Please try again.