Skip to content
Newer
Older
100755 802 lines (728 sloc) 21 KB
321d6cd @feeley Miscellaneous changes to improve flexibility of installation.
authored Dec 23, 2008
1 #!/usr/bin/env gsi-script
1b67821 @feeley Initial commit of Gambit-C v4.0.0
authored Aug 25, 2007
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"))
9e179cb @feeley Add procedures append-vectors, subvector-fill!, subvector-move!, vect…
authored Sep 5, 2009
409 (print "*** WARNING: " sym " is not defined as a procedure\n"))
1b67821 @feeley Initial commit of Gambit-C v4.0.0
authored Aug 25, 2007
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)))
9e179cb @feeley Add procedures append-vectors, subvector-fill!, subvector-move!, vect…
authored Sep 5, 2009
416 (print
417 port: out
418 "\n"
419 "@deffn procedure " name "\n"
420 "@end deffn\n")))))
1b67821 @feeley Initial commit of Gambit-C v4.0.0
authored Aug 25, 2007
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 ))
Something went wrong with that request. Please try again.