doc/checkdoc.scm

   1 #!/usr/bin/env gsi-script
   2
   3 (let ()
   4
   5 (define shell-prompt "$ ")
   6 (define scheme-prompt "> ")
   7 (define scheme-prompt1 "1> ")
   8 (define scheme-prompt2 "2> ")
   9 (define scheme-prompt3 "3> ")
  10
  11 (define os-name
  12   (let ((p (open-process "uname")))
  13     (let ((name (read-line p)))
  14       (close-port p)
  15       name)))
  16
  17 (define r5rs-standard-procedures '(
  18
  19 ; r4rs
  20
  21 *
  22 +
  23 -
  24 /
  25 <
  26 <=
  27 =
  28 >
  29 >=
  30 abs
  31 acos
  32 angle
  33 append
  34 apply
  35 asin
  36 assoc
  37 assq
  38 assv
  39 atan
  40 boolean?
  41 caaaar
  42 caaadr
  43 caaar
  44 caadar
  45 caaddr
  46 caadr
  47 caar
  48 cadaar
  49 cadadr
  50 cadar
  51 caddar
  52 cadddr
  53 caddr
  54 cadr
  55 call-with-current-continuation
  56 call-with-input-file
  57 call-with-output-file
  58 car
  59 cdaaar
  60 cdaadr
  61 cdaar
  62 cdadar
  63 cdaddr
  64 cdadr
  65 cdar
  66 cddaar
  67 cddadr
  68 cddar
  69 cdddar
  70 cddddr
  71 cdddr
  72 cddr
  73 cdr
  74 ceiling
  75 char->integer
  76 char-alphabetic?
  77 char-ci<=?
  78 char-ci<?
  79 char-ci=?
  80 char-ci>=?
  81 char-ci>?
  82 char-downcase
  83 char-lower-case?
  84 char-numeric?
  85 char-ready?
  86 char-upcase
  87 char-upper-case?
  88 char-whitespace?
  89 char<=?
  90 char<?
  91 char=?
  92 char>=?
  93 char>?
  94 char?
  95 close-input-port
  96 close-output-port
  97 complex?
  98 cons
  99 cos
 100 current-input-port
 101 current-output-port
 102 denominator
 103 display
 104 eof-object?
 105 eq?
 106 equal?
 107 eqv?
 108 even?
 109 exact->inexact
 110 exact?
 111 exp
 112 expt
 113 floor
 114 for-each
 115 force
 116 gcd
 117 imag-part
 118 inexact->exact
 119 inexact?
 120 input-port?
 121 integer->char
 122 integer?
 123 lcm
 124 length
 125 list
 126 list->string
 127 list->vector
 128 list-ref
 129 list-tail
 130 list?
 131 load
 132 log
 133 magnitude
 134 make-polar
 135 make-rectangular
 136 make-string
 137 make-vector
 138 map
 139 max
 140 member
 141 memq
 142 memv
 143 min
 144 modulo
 145 negative?
 146 newline
 147 not
 148 null?
 149 number->string
 150 number?
 151 numerator
 152 odd?
 153 open-input-file
 154 open-output-file
 155 output-port?
 156 pair?
 157 peek-char
 158 positive?
 159 procedure?
 160 quotient
 161 rational?
 162 rationalize
 163 read
 164 read-char
 165 real-part
 166 real?
 167 remainder
 168 reverse
 169 round
 170 set-car!
 171 set-cdr!
 172 sin
 173 sqrt
 174 string
 175 string->list
 176 string->number
 177 string->symbol
 178 string-append
 179 string-ci<=?
 180 string-ci<?
 181 string-ci=?
 182 string-ci>=?
 183 string-ci>?
 184 string-copy
 185 string-fill!
 186 string-length
 187 string-ref
 188 string-set!
 189 string<=?
 190 string<?
 191 string=?
 192 string>=?
 193 string>?
 194 string?
 195 substring
 196 symbol->string
 197 symbol?
 198 tan
 199 transcript-off
 200 transcript-on
 201 truncate
 202 vector
 203 vector->list
 204 vector-fill!
 205 vector-length
 206 vector-ref
 207 vector-set!
 208 vector?
 209 with-input-from-file
 210 with-output-to-file
 211 write
 212 write-char
 213 zero?
 214
 215 ; r5rs
 216
 217 call-with-values
 218 dynamic-wind
 219 eval
 220 interaction-environment
 221 null-environment
 222 scheme-report-environment
 223 values
 224 ))
 225
 226 (define (all-symbols)
 227
 228   (define (symbol-next x)
 229     (##vector-ref x 2))
 230
 231   (define (f x)
 232     (if (symbol? x)
 233         (cons x
 234               (f (symbol-next x)))
 235         '()))
 236
 237   (apply append (map f (cdr (vector->list (##symbol-table))))))
 238
 239 (define (global? x)
 240   (not (##unbound? (##global-var-ref (##make-global-var x)))))
 241
 242 (define (exported-procedure? sym)
 243   (and (> (string-length (symbol->string sym)) 2)
 244        (and (not (string=? "##" (substring (symbol->string sym) 0 2)))
 245             (not (string=? " " (substring (symbol->string sym) 0 1))))
 246        (procedure? (##global-var-ref (##make-global-var sym)))))
 247
 248 (define (keep keep? lst)
 249   (cond ((null? lst)       '())
 250         ((keep? (car lst)) (cons (car lst) (keep keep? (cdr lst))))
 251         (else              (keep keep? (cdr lst)))))
 252
 253 (define (sort-list l <?)
 254
 255   (define (mergesort l)
 256
 257     (define (merge l1 l2)
 258       (cond ((null? l1) l2)
 259             ((null? l2) l1)
 260             (else
 261              (let ((e1 (car l1)) (e2 (car l2)))
 262                (if (<? e1 e2)
 263                  (cons e1 (merge (cdr l1) l2))
 264                  (cons e2 (merge l1 (cdr l2))))))))
 265
 266     (define (split l)
 267       (if (or (null? l) (null? (cdr l)))
 268         l
 269         (cons (car l) (split (cddr l)))))
 270
 271     (if (or (null? l) (null? (cdr l)))
 272       l
 273       (let* ((l1 (mergesort (split l)))
 274              (l2 (mergesort (split (cdr l)))))
 275         (merge l1 l2))))
 276
 277   (mergesort l))
 278
 279 (define (sort-syms lst)
 280   (sort-list lst
 281              (lambda (x y) (string<? (symbol->string x) (symbol->string y)))))
 282
 283 '
 284 (begin
 285 (for-each
 286  (lambda (sym)
 287    (if (and (exported-procedure? sym)
 288             (not (memq sym r5rs-standard-procedures)))
 289        (pp sym)))
 290  (sort-syms (all-symbols)))
 291 (exit))
 292
 293 (let ()
 294
 295 (define exported-procedures
 296   (sort-syms (keep exported-procedure? (all-symbols))))
 297
 298 (define (extract-deffn lines)
 299   (map
 300    extract-deffn-head
 301    (extract-groups
 302     lines
 303     (lambda (line) (prefix? "@deffn " line))
 304     (lambda (line) (prefix? "@end deffn" line)))))
 305
 306 (define (extract-groups lines begin? end?)
 307   (let loop1 ((lines lines)
 308               (rev-groups '()))
 309     (cond ((null? lines)
 310            (reverse rev-groups))
 311           ((begin? (car lines))
 312            (let loop2 ((lines (cdr lines))
 313                        (rev-gr (list (car lines))))
 314              (cond ((null? lines)
 315                     (display "*** WARNING: unterminated group\n")
 316                     (reverse rev-groups))
 317                    ((end? (car lines))
 318                     (loop1 (cdr lines)
 319                            (cons (reverse (cons (car lines) rev-gr))
 320                                  rev-groups)))
 321                    (else
 322                     (loop2 (cdr lines)
 323                            (cons (car lines) rev-gr))))))
 324           (else
 325            (loop1 (cdr lines) rev-groups)))))
 326
 327 (define (extract-deffn-head deffn-lines)
 328   (let loop1 ((lines deffn-lines) (rev-head '()))
 329     (cond ((and (not (null? lines))
 330                 (prefix? "@deffn" (car lines)))
 331            (let ((words (split-at-spaces (car lines))))
 332              (if (< (length words) 3)
 333                  (error "ill-formed deffn")
 334                  (let ((deffn-key (car words))
 335                        (a (cadr words))
 336                        (b (caddr words)))
 337                    (loop1 (cdr lines)
 338                           (cons (if (and (string=? a "{special")
 339                                          (string=? b "form}"))
 340                                     (list (string->symbol (cadddr words))
 341                                           (string-append a " " b)
 342                                           (car lines))
 343                                     (list (string->symbol b)
 344                                           a
 345                                           (car lines)))
 346                                 rev-head))))))
 347           (else
 348            (cons (reverse rev-head)
 349                  lines)))))
 350
 351 (define (prefix? str1 str2)
 352   (here? str1 str2 0))
 353
 354 (define (suffix? str1 str2)
 355   (here? str1 str2 (- (string-length str2) (string-length str1))))
 356
 357 (define (here? str1 str2 pos)
 358   (let ((len1 (string-length str1))
 359         (len2 (string-length str2)))
 360     (and (<= (+ pos len1) len2)
 361          (string=? str1 (substring str2 pos (+ pos len1))))))
 362
 363 (define (every? pred? lst)
 364   (or (null? lst)
 365       (and (pred? (car lst))
 366            (every? pred? (cdr lst)))))
 367
 368 (define (any? pred? lst)
 369   (and (not (null? lst))
 370        (or (pred? (car lst))
 371            (any? pred? (cdr lst)))))
 372
 373 (define (find pred? lst)
 374   (cond ((null? lst)
 375          #f)
 376         ((pred? (car lst)))
 377         (else
 378          (find pred? (cdr lst)))))
 379
 380 (define (split-at-spaces str)
 381   (with-input-from-string str
 382     (lambda ()
 383       (read-all (current-input-port)
 384                 (lambda (p) (read-line p #\space))))))
 385
 386 (define (check-missing-procedures doc-lines out)
 387   (let ((deffns
 388           (extract-deffn doc-lines)))
 389
 390     (define (procedure-documented? sym)
 391       (let ((d
 392              (find
 393               (lambda (deffn)
 394                 (find
 395                  (lambda (head)
 396                    (if (eq? (car head) sym)
 397                        (cons head deffn)
 398                        #f))
 399                  (car deffn)))
 400               deffns)))
 401         (cond ((not d)
 402                #f)
 403               (else
 404                (let ((head
 405                       (car d))
 406                      (deffn
 407                        (cdr d)))
 408                  (if (not (string=? (cadr head) "procedure"))
 409                      (print "*** WARNING: " sym " is not defined as a procedure\n"))
 410                  #t)))))
 411
 412     (define (check-documented sym)
 413       (if (not (memq sym r5rs-standard-procedures))
 414           (if (not (procedure-documented? sym))
 415               (let ((name (symbol->string sym)))
 416                 (print
 417                  port: out
 418                  "\n"
 419                  "@deffn procedure " name "\n"
 420                  "@end deffn\n")))))
 421
 422     (define (check-that-exported-procedures-are-documented)
 423       (for-each check-documented exported-procedures))
 424
 425     (check-that-exported-procedures-are-documented)))
 426
 427 (define os-name-prefix
 428   (string-append "\n" os-name " "))
 429
 430 (define (exec inputs)
 431   (let ((p
 432          (open-process
 433           (list path: "bash"
 434                 arguments: '()
 435                 pseudo-terminal: #t
 436                 eol-encoding: 'cr-lf
 437                 buffering: #t)))
 438         (rev-output
 439          '()))
 440
 441     (define (recv)
 442       (recv-timeout 10))
 443
 444     (define (recv-timeout max-wait-after-newline)
 445
 446       (define max-wait-before-newline .1)
 447       (define max-idle-time .1)
 448
 449       (input-port-timeout-set! p max-wait-before-newline)
 450       (let loop1 ((rev-output '()))
 451         (let ((c (read-char p)))
 452           (if (and (char? c) (not (char=? c #\newline)))
 453               (begin
 454 ;                (write-char c)
 455                 (input-port-timeout-set! p max-idle-time)
 456                 (loop1 (cons c rev-output)))
 457               (begin
 458                 (input-port-timeout-set! p max-wait-after-newline)
 459                 (let loop2 ((rev-output
 460                              (if (char? c)
 461                                  (cons c rev-output)
 462                                  rev-output)))
 463                   (let ((c (read-char p)))
 464                     (if (char? c)
 465                         (begin
 466 ;                          (write-char c)
 467                           (input-port-timeout-set! p max-idle-time)
 468                           (loop2 (cons c rev-output)))
 469                         rev-output))))))))
 470
 471     (define (send input)
 472       (let ((input-text
 473              (plain-text input)))
 474         (display (string-append input-text "\n") p)
 475         (force-output p)
 476         (let* ((rev-last-output
 477                 (recv))
 478                (last-output
 479                 (clean-up (list->string (reverse rev-last-output))))
 480                (expect
 481                 (string-append input-text "\n")))
 482           (set! rev-output
 483                 (cons (string-append
 484                        "\n"
 485                        (if (prefix? expect last-output)
 486                            (substring last-output
 487                                       (string-length expect)
 488                                       (string-length last-output))
 489                            last-output))
 490                       (cons input
 491                             rev-output))))))
 492
 493     (display (string-append "PS1=\"" shell-prompt "\"\n") p)
 494     (display "export C_INCLUDE_PATH=../include\n" p)
 495     (display "export LIBRARY_PATH=../lib\n" p)
 496     (force-output p)
 497
 498     (recv-timeout .1)
 499
 500     (set! rev-output (list shell-prompt))
 501
 502     (for-each send inputs)
 503
 504     (let ((output (reverse rev-output)))
 505       (close-port p)
 506       output)))
 507
 508 (define (parse-info body)
 509
 510   (define (parse rev-accum start i cont)
 511
 512     (define (add)
 513       (if (< start i)
 514           (cons (substring body start i)
 515                 rev-accum)
 516           rev-accum))
 517
 518     (if (< i (string-length body))
 519         (let ((c (string-ref body i)))
 520           (cond ((char=? c #\})
 521                  (cont (reverse (add))
 522                        i))
 523                 ((and (< (+ i 1) (string-length body))
 524                       (char=? c #\@))
 525                  (let ((first (string-ref body (+ i 1))))
 526                    (if (memv first '(#\@ #\{ #\}))
 527                        (parse (add)
 528                               (+ i 1)
 529                               (+ i 2)
 530                               cont)
 531                        (let loop ((j (+ i 2)))
 532                          (if (and (< j (string-length body))
 533                                   (char-alphabetic?
 534                                    (string-ref body j)))
 535                              (loop (+ j 1))
 536                              (let ((key (substring body (+ i 1) j)))
 537                                (if (and (< j (string-length body))
 538                                         (char=? (string-ref body j)
 539                                                 #\{))
 540                                    (parse (list (string->symbol key))
 541                                           (+ j 1)
 542                                           (+ j 1)
 543                                           (lambda (tree i)
 544                                             (if (and (< i (string-length body))
 545                                                      (char=?
 546                                                       (string-ref body i)
 547                                                       #\}))
 548                                                 (parse (cons tree
 549                                                              (add))
 550                                                        (+ i 1)
 551                                                        (+ i 1)
 552                                                        cont)
 553                                                 (error "} expected"))))
 554                                    (error "{ expected"))))))))
 555                 (else
 556                  (parse rev-accum start (+ i 1) cont))))
 557         (cont (reverse (add))
 558               i)))
 559
 560   (parse '()
 561          0
 562          0
 563          (lambda (tree i)
 564            (if (= i (string-length body))
 565                tree
 566                (error "syntax error")))))
 567
 568 (define (replace expr replacement)
 569   (lambda (str pos cont)
 570     (let loop ((i 0) (j pos))
 571       (if (< i (string-length expr))
 572           (if (and (< j (string-length str))
 573                    (let ((x (string-ref expr i))
 574                          (c (string-ref str j)))
 575                      (cond ((or (char=? x #\*) (char=? x #\?))
 576                             (error "misplaced * or ?"))
 577                            ((char=? x #\#)
 578                             (char-numeric? c))
 579                            (else
 580                             (char=? x c)))))
 581               (loop (cond ((and (< (+ i 1) (string-length expr))
 582                                 (char=? (string-ref expr (+ i 1)) #\*))
 583                            i)
 584                           ((and (< (+ i 1) (string-length expr))
 585                                 (char=? (string-ref expr (+ i 1)) #\?))
 586                            (+ i 2))
 587                           (else
 588                            (+ i 1)))
 589                     (+ j 1))
 590               (cond ((and (< (+ i 1) (string-length expr))
 591                           (char=? (string-ref expr (+ i 1)) #\*))
 592                      (loop (+ i 2)
 593                            j))
 594                     ((and (< (+ i 1) (string-length expr))
 595                           (char=? (string-ref expr (+ i 1)) #\?))
 596                      (loop (+ i 2)
 597                            j))
 598                     (else
 599                      (cont str pos #f))))
 600           (cont str j replacement)))))
 601
 602 (define (either2 t1 t2)
 603   (lambda (str pos cont)
 604     (t1 str
 605         pos
 606         (lambda (str new-pos replacement)
 607           (if replacement
 608               (cont str new-pos replacement)
 609               (t2 str
 610                   pos
 611                   cont))))))
 612
 613 (define (either transformers)
 614   (if (null? transformers)
 615       (lambda (str pos cont)
 616         (cont str pos #f))
 617       (either2 (car transformers)
 618                (either (cdr transformers)))))
 619
 620 (define (transform str transformer)
 621   (let loop ((i 0) (j 0) (rev-result '()))
 622     (if (< j (string-length str))
 623         (transformer
 624          str
 625          j
 626          (lambda (str new-pos replacement)
 627            (if replacement
 628                (loop new-pos
 629                      new-pos
 630                      (if (< i j)
 631                          (cons replacement
 632                                (cons (substring str i j)
 633                                      rev-result))
 634                          (cons replacement
 635                                rev-result)))
 636                (loop i
 637                      (+ j 1)
 638                      rev-result))))
 639         (apply string-append
 640                (reverse
 641                 (if (< i j)
 642                     (cons (substring str i j) rev-result)
 643                     rev-result))))))
 644
 645 (define (clean-up str)
 646   (transform
 647    str
 648    (either
 649     (list (replace "gsi(##*) malloc:" "gsi(29744) malloc:")
 650           (replace "\33[#*A" "")
 651           (replace "\33[#*A" "")
 652           (replace "\33[#*B" "")
 653           (replace "\33[#*C" "")
 654           (replace "\33[#*D" "")
 655           (replace "\33[46m" "")
 656           (replace "\33[1m" "")
 657           (replace "\33[m" "")))))
 658
 659 (define (plain-text tree)
 660   (cond ((string? tree)
 661          tree)
 662         ((pair? tree)
 663          (apply string-append
 664                 (map plain-text (cdr tree))))
 665         (else
 666          (error "unknown info tree node"))))
 667
 668 (define (display-info tree)
 669   (cond ((string? tree)
 670          (let loop ((i 0))
 671            (if (< i (string-length tree))
 672                (let ((c (string-ref tree i)))
 673                  (cond ((char=? c #\@)
 674                         (display "@@"))
 675                        ((char=? c #\{)
 676                         (display "@{"))
 677                        ((char=? c #\})
 678                         (display "@}"))
 679                        (else
 680                         (display c)))
 681                  (loop (+ i 1))))))
 682         ((pair? tree)
 683          (display "@")
 684          (display (car tree))
 685          (display "{")
 686          (for-each display-info (cdr tree))
 687          (display "}"))
 688         (else
 689          (error "unknown info tree node"))))
 690
 691 (define (remove-trailing-prompt str)
 692
 693   (define (remove prompt)
 694     (if (suffix? prompt str)
 695         (substring str
 696                    0
 697                    (- (string-length str) (string-length prompt)))
 698         #f))
 699
 700   (or (remove scheme-prompt1)
 701       (remove scheme-prompt2)
 702       (remove scheme-prompt3)
 703       (remove scheme-prompt)
 704       (remove shell-prompt)
 705       str))
 706
 707 (define (check-example info)
 708   (let* ((tree
 709           (parse-info info))
 710          (type
 711 'no-execute #;
 712           (cond ((equal? (car tree) shell-prompt)
 713                  'shell)
 714                 ((equal? (car tree) scheme-prompt)
 715                  'scheme)
 716                 ((and (pair? (car tree))
 717                       (equal? (car (car tree)) 'b))
 718                  'no-execute)
 719                 (else
 720                  'unknown)))
 721          (same-os?
 722           (or (not (eq? type 'shell))
 723               (not (pair? (cdr tree)))
 724               (not (equal? (cadr tree) '(b "uname -srmp")))
 725               (not (pair? (cddr tree)))
 726               (not (string? (caddr tree)))
 727               (prefix? os-name-prefix (caddr tree)))))
 728     (cond ((and same-os?
 729                 (memq type '(shell scheme)))
 730            (let* ((raw-inputs
 731                    (keep (lambda (x) (and (pair? x) (eq? (car x) 'b))) tree))
 732                   (inputs
 733                    (if (eq? type 'scheme)
 734                        (append '("gsi -:h4000") raw-inputs)
 735                        raw-inputs))
 736                   (raw-output
 737                    (exec inputs))
 738                   (output
 739                    (if (eq? type 'scheme)
 740                        (cons scheme-prompt (cdddr raw-output))
 741                        raw-output))
 742                   (output-str
 743                    (remove-trailing-prompt
 744                     (with-output-to-string
 745                       ""
 746                       (lambda ()
 747                         (for-each display-info output))))))
 748              output-str))
 749           ((eq? type 'no-execute)
 750            info)
 751           (else
 752            (display "---------------------------------- WARNING, example skipped:\n")
 753            (display info)
 754            info))))
 755
 756 (define (check-doc filename)
 757   (let ((doc-lines
 758          (with-input-from-file
 759              filename
 760            (lambda ()
 761              (read-all (current-input-port) read-line)))))
 762
 763     (define (addnl s)
 764       (string-append s "\n"))
 765
 766     (let* ((out (open-output-file (string-append filename "-correct"))))
 767       (let loop1 ((lines doc-lines))
 768         (if (null? lines)
 769             (close-output-port out)
 770             (let ((x (car lines)))
 771               (cond ((member x
 772                              '("@example"
 773                                "@smallexample"))
 774                      (let ((end
 775                             (string-append "@end "
 776                                            (substring x 1 (string-length x)))))
 777                        (let loop2 ((lines (cdr lines)) (lst '()))
 778                          (let ((y (car lines)))
 779                            (if (equal? y end)
 780                                (let* ((info
 781                                        (apply string-append
 782                                               (map addnl (reverse lst))))
 783                                       (correct-example
 784                                        (check-example info)))
 785                                  (display x out)
 786                                  (display "\n" out)
 787                                  (display correct-example out)
 788                                  (display end out)
 789                                  (display "\n" out)
 790                                  (loop1 (cdr lines)))
 791                                (loop2 (cdr lines) (cons y lst)))))))
 792                     (else
 793                      (display x out)
 794                      (display "\n" out)
 795                      (if (equal? x "The procedures in this section are not yet documented.")
 796                          (check-missing-procedures doc-lines out))
 797                      (loop1 (cdr lines))))))))))
 798
 799 (check-doc "gambit-c.txi")
 800
 801 ))