tests/test10.scm

   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 ;;;============================================================================