Skip to content
This repository
Fetching contributors…

Cannot retrieve contributors at this time

file 156 lines (132 sloc) 4.833 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156
;;;============================================================================

;;; File: "check-consistency.scm", Time-stamp: <2008-11-26 20:24:28 feeley>

;;; Copyright (c) 2008 by Marc Feeley, All Rights Reserved.

;;;============================================================================

;; Check that the lib/gambit#.scm file is consistent with the
;; compiler's public procedures and special forms.

(define (main)

  (define pretend-defined-by-gambit '(
define-syntax
let-syntax
letrec-syntax
syntax-rules
six.!
six.break
six.case
six.clause
six.continue
six.goto
six.label
six.return
six.switch
six.x:-y
default-random-source
  ))

  (define (keep keep? lst)
    (cond ((null? lst) '())
          ((keep? (car lst)) (cons (car lst) (keep keep? (cdr lst))))
          (else (keep keep? (cdr lst)))))

  (define (sort-list lst <?)

    (define (mergesort lst)

      (define (merge lst1 lst2)
        (cond ((null? lst1) lst2)
              ((null? lst2) lst1)
              (else
               (let ((e1 (car lst1)) (e2 (car lst2)))
                 (if (<? e1 e2)
                     (cons e1 (merge (cdr lst1) lst2))
                     (cons e2 (merge lst1 (cdr lst2))))))))

      (define (split lst)
        (if (or (null? lst) (null? (cdr lst)))
            lst
            (cons (car lst) (split (cddr lst)))))

      (if (or (null? lst) (null? (cdr lst)))
          lst
          (let* ((lst1 (mergesort (split lst)))
                 (lst2 (mergesort (split (cdr lst)))))
            (merge lst1 lst2))))

    (mergesort lst))

  (define (symbol-table->list st)
    (apply append
           (map (lambda (s)
                  (let loop ((s s) (lst '()))
                    (if (symbol? s)
                        (loop (##vector-ref s 2) (cons s lst))
                        (reverse lst))))
                (vector->list st))))

  (define (public-procedure? s)
    (if (let ((str (symbol->string s)))
          (or (memv #\# (string->list str))
              #;
(and (>= (string-length str) 2)
(equal? (substring str 0 2) "##"))
              (and (>= (string-length str) 1)
                   (equal? (substring str 0 1) " "))))
              
        #f
        (let ((val (##global-var-ref (##make-global-var s))))
          (procedure? val))))

  (define (extract-macros cte)
    (cond ((##cte-top? cte)
           '())
          ((##cte-macro? cte)
           (cons (##cte-macro-name cte)
                 (extract-macros (##cte-parent-cte cte))))
          (else
           (extract-macros (##cte-parent-cte cte)))))

  (define (read-namespace-names filename)
    (let ((ns (assq '##namespace (with-input-from-file filename read-all))))
      (if ns
          (cdr (cadr ns))
          '())))

  (define (gambit-macros)
    (extract-macros (##cte-top-cte ##interaction-cte)))

  (define (sort-symbols lst)
    (sort-list
     lst
     (lambda (x y) (string<? (symbol->string x) (symbol->string y)))))

  (let* ((public-procedures
          (keep public-procedure?
                (symbol-table->list (##symbol-table))))
         (public-macros
          (gambit-macros))
         (sorted-public-names
          (sort-symbols
           (append public-macros
                   public-procedures
                   pretend-defined-by-gambit)))
         (r4rs-public-names
          (read-namespace-names "../lib/r4rs#.scm"))
         (r5rs-public-names
          (append
           r4rs-public-names
           (read-namespace-names "../lib/r5rs#.scm")))
         (gambit-public-names
          (append
           r5rs-public-names
           (read-namespace-names "../lib/gambit#.scm")))
         (missing-from-gambit-public-names
          (keep (lambda (name)
                  (not (memq name gambit-public-names)))
                sorted-public-names))
         (extras-in-gambit-public-names
          (keep (lambda (name)
                  (not (memq name sorted-public-names)))
                gambit-public-names)))

    (if (or (not (null? extras-in-gambit-public-names))
            (not (null? missing-from-gambit-public-names)))
        (begin
          (display "************ file lib/gambit#.scm needs to be edited ************\n")
          (newline)
          (if (not (null? extras-in-gambit-public-names))
              (begin
                (display "==== these names should be REMOVED ====\n")
                (for-each pp extras-in-gambit-public-names)
                (newline)))
          (if (not (null? missing-from-gambit-public-names))
              (begin
                (display "==== these names should be ADDED ====\n")
                (for-each pp missing-from-gambit-public-names)))
          (exit 1))
        (exit))))

(main)

;;;============================================================================
Something went wrong with that request. Please try again.